home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
lsp
/
seq.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-04
|
4KB
|
115 lines
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; seq.lsp
;;;;
;;;; sequence routines
(in-package 'lisp)
(export '(make-sequence concatenate map some every notany notevery))
(in-package 'system)
(proclaim '(optimize (safety 2) (space 3)))
(defun make-sequence (type size &key (initial-element nil iesp)
&aux element-type sequence)
(setq element-type
(cond ((eq type 'list)
(return-from make-sequence
(if iesp
(make-list size :initial-element initial-element)
(make-list size))))
((or (eq type 'simple-string) (eq type 'string)) 'string-char)
((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit)
((or (eq type 'simple-vector) (eq type 'vector)) t)
(t
(setq type (normalize-type type))
(when (eq (car type) 'list)
(return-from make-sequence
(if iesp
(make-list size :initial-element initial-element)
(make-list size))))
(unless (or (eq (car type) 'array)
(eq (car type) 'simple-array))
(error "~S is not a sequence type." type))
(or (cadr type) t))))
(setq sequence (si:make-vector element-type size nil nil nil nil nil))
(when iesp
(do ((i 0 (1+ i))
(size size))
((>= i size))
(declare (fixnum i size))
(setf (elt sequence i) initial-element)))
sequence)
(defun concatenate (result-type &rest sequences)
(do ((x (make-sequence result-type
(apply #'+ (mapcar #'length sequences))))
(s sequences (cdr s))
(i 0))
((null s) x)
(declare (fixnum i))
(do ((j 0 (1+ j))
(n (length (car s))))
((>= j n))
(declare (fixnum j n))
(setf (elt x i) (elt (car s) j))
(incf i))))
(defun map (result-type function sequence &rest more-sequences)
(setq more-sequences (cons sequence more-sequences))
(let ((l (apply #'min (mapcar #'length more-sequences))))
(if (null result-type)
(do ((i 0 (1+ i))
(l l))
((>= i l) nil)
(declare (fixnum i l))
(apply function (mapcar #'(lambda (z) (elt z i))
more-sequences)))
(let ((x (make-sequence result-type l)))
(do ((i 0 (1+ i))
(l l))
((>= i l) x)
(declare (fixnum i l))
(setf (elt x i)
(apply function (mapcar #'(lambda (z) (elt z i))
more-sequences))))))))
(defun some (predicate sequence &rest more-sequences)
(setq more-sequences (cons sequence more-sequences))
(do ((i 0 (1+ i))
(l (apply #'min (mapcar #'length more-sequences))))
((>= i l) nil)
(declare (fixnum i l))
(let ((that-value
(apply predicate
(mapcar #'(lambda (z) (elt z i)) more-sequences))))
(when that-value (return that-value)))))
(defun every (predicate sequence &rest more-sequences)
(setq more-sequences (cons sequence more-sequences))
(do ((i 0 (1+ i))
(l (apply #'min (mapcar #'length more-sequences))))
((>= i l) t)
(declare (fixnum i l))
(unless (apply predicate (mapcar #'(lambda (z) (elt z i)) more-sequences))
(return nil))))
(defun notany (predicate sequence &rest more-sequences)
(not (apply #'some predicate sequence more-sequences)))
(defun notevery (predicate sequence &rest more-sequences)
(not (apply #'every predicate sequence more-sequences)))